home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / C / Applications / MacPerl 5.0.3 / Preinstalled MacPerl (FAT) / lib / Term / Cap.pm next >
Encoding:
Text File  |  1995-03-20  |  3.8 KB  |  177 lines  |  [TEXT/McPL]
  1. die "Term::Cap not (yet) implemented on the Mac";
  2.  
  3. package Term::Cap;
  4. require 5.000;
  5. require Exporter;
  6. use Carp;
  7.  
  8. @ISA = qw(Exporter);
  9. @EXPORT = qw(&Tgetent &Tputs &Tgoto $ispeed $ospeed %TC);
  10.  
  11. # $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
  12. #
  13. # Usage:
  14. #    require 'ioctl.pl';
  15. #    ioctl(TTY,$TIOCGETP,$foo);
  16. #    ($ispeed,$ospeed) = unpack('cc',$foo);
  17. #    use Termcap;
  18. #    &Tgetent('vt100');    # sets $TC{'cm'}, etc.
  19. #    &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
  20. #    &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
  21. #
  22. sub Tgetent {
  23.     local($TERM) = @_;
  24.     local($TERMCAP,$_,$entry,$loop,$field);
  25.  
  26.     warn "Tgetent: no ospeed set" unless $ospeed;
  27.     foreach $key (keys(%TC)) {
  28.     delete $TC{$key};
  29.     }
  30.     $TERM = $ENV{'TERM'} unless $TERM;
  31.     $TERM =~ s/(\W)/\\$1/g;
  32.     $TERMCAP = $ENV{'TERMCAP'};
  33.     $TERMCAP = '/etc/termcap' unless $TERMCAP;
  34.     if ($TERMCAP !~ m:^/:) {
  35.     if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
  36.         $TERMCAP = '/etc/termcap';
  37.     }
  38.     }
  39.     if ($TERMCAP =~ m:^/:) {
  40.     $entry = '';
  41.     do {
  42.         $loop = "
  43.         open(TERMCAP,'<$TERMCAP') || croak \"Can't open $TERMCAP\";
  44.         while (<TERMCAP>) {
  45.         next if /^#/;
  46.         next if /^\t/;
  47.         if (/(^|\\|)${TERM}[:\\|]/) {
  48.             chop;
  49.             while (chop eq '\\\\') {
  50.             \$_ .= <TERMCAP>;
  51.             chop;
  52.             }
  53.             \$_ .= ':';
  54.             last;
  55.         }
  56.         }
  57.         close TERMCAP;
  58.         \$entry .= \$_;
  59.         ";
  60.         eval $loop;
  61.     } while s/:tc=([^:]+):/:/ && ($TERM = $1);
  62.     $TERMCAP = $entry;
  63.     }
  64.  
  65.     foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
  66.     if ($field =~ /^\w\w$/) {
  67.         $TC{$field} = 1;
  68.     }
  69.     elsif ($field =~ /^(\w\w)#(.*)/) {
  70.         $TC{$1} = $2 unless defined $TC{$1};
  71.     }
  72.     elsif ($field =~ /^(\w\w)=(.*)/) {
  73.         $entry = $1;
  74.         $_ = $2;
  75.         s/\\E/\033/g;
  76.         s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
  77.         s/\\n/\n/g;
  78.         s/\\r/\r/g;
  79.         s/\\t/\t/g;
  80.         s/\\b/\b/g;
  81.         s/\\f/\f/g;
  82.         s/\\\^/\377/g;
  83.         s/\^\?/\177/g;
  84.         s/\^(.)/pack('c',ord($1) & 31)/eg;
  85.         s/\\(.)/$1/g;
  86.         s/\377/^/g;
  87.         $TC{$entry} = $_ unless defined $TC{$entry};
  88.     }
  89.     }
  90.     $TC{'pc'} = "\0" unless defined $TC{'pc'};
  91.     $TC{'bc'} = "\b" unless defined $TC{'bc'};
  92. }
  93.  
  94. @Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
  95.  
  96. sub Tputs {
  97.     local($string,$affcnt,$FH) = @_;
  98.     local($ms);
  99.     if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
  100.     $ms = $1;
  101.     $ms *= $affcnt if $2;
  102.     $string = $3;
  103.     $decr = $Tputs[$ospeed];
  104.     if ($decr > .1) {
  105.         $ms += $decr / 2;
  106.         $string .= $TC{'pc'} x ($ms / $decr);
  107.     }
  108.     }
  109.     print $FH $string if $FH;
  110.     $string;
  111. }
  112.  
  113. sub Tgoto {
  114.     local($string) = shift(@_);
  115.     local($result) = '';
  116.     local($after) = '';
  117.     local($code,$tmp) = @_;
  118.     local(@tmp);
  119.     @tmp = ($tmp,$code);
  120.     local($online) = 0;
  121.     while ($string =~ /^([^%]*)%(.)(.*)/) {
  122.     $result .= $1;
  123.     $code = $2;
  124.     $string = $3;
  125.     if ($code eq 'd') {
  126.         $result .= sprintf("%d",shift(@tmp));
  127.     }
  128.     elsif ($code eq '.') {
  129.         $tmp = shift(@tmp);
  130.         if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
  131.         if ($online) {
  132.             ++$tmp, $after .= $TC{'up'} if $TC{'up'};
  133.         }
  134.         else {
  135.             ++$tmp, $after .= $TC{'bc'};
  136.         }
  137.         }
  138.         $result .= sprintf("%c",$tmp);
  139.         $online = !$online;
  140.     }
  141.     elsif ($code eq '+') {
  142.         $result .= sprintf("%c",shift(@tmp)+ord($string));
  143.         $string = substr($string,1,99);
  144.         $online = !$online;
  145.     }
  146.     elsif ($code eq 'r') {
  147.         ($code,$tmp) = @tmp;
  148.         @tmp = ($tmp,$code);
  149.         $online = !$online;
  150.     }
  151.     elsif ($code eq '>') {
  152.         ($code,$tmp,$string) = unpack("CCa99",$string);
  153.         if ($tmp[$[] > $code) {
  154.         $tmp[$[] += $tmp;
  155.         }
  156.     }
  157.     elsif ($code eq '2') {
  158.         $result .= sprintf("%02d",shift(@tmp));
  159.         $online = !$online;
  160.     }
  161.     elsif ($code eq '3') {
  162.         $result .= sprintf("%03d",shift(@tmp));
  163.         $online = !$online;
  164.     }
  165.     elsif ($code eq 'i') {
  166.         ($code,$tmp) = @tmp;
  167.         @tmp = ($code+1,$tmp+1);
  168.     }
  169.     else {
  170.         return "OOPS";
  171.     }
  172.     }
  173.     $result . $string . $after;
  174. }
  175.  
  176. 1;
  177.